BBS in a Box 3/BBS in a box - Trilogy III.iso/Files/Bus/T-Z/Time Calc/TimeCalc.srce

Text File | 1990-03-02 | 7.5 KB | 369 lines | [TEXT/PJMM]

{TimeCalc by Gre7g Luterman, Ballistic Grapeware}

{provisions: you may change my code (not comments), but I retain}
{first credits, and postcards come to me. you may add to my}
{code, but you may not sell it or what it becomes without my}
{blessings in writing}
program timecalc;

    const
        maxhist = 50;

    var
        thedialog: dialogptr;
        dstorage: dialogrecord;
        list: listhandle;
        listrect: rect;
        state: (first, add, sub, eq);
        editing: (ehour, emin, esec);
        current: record
                total: longint;
                hour, min, sec: integer;
                negative: boolean;
            end;
        memory: longint;

    procedure drawlist (dialog: dialogptr; item: integer);
        var
            thergn: rgnhandle;
            therect: rect;
    begin
        thergn := newrgn;
        with listrect do
            setrect(therect, left - 1, top - 1, right + 16, bottom + 1);
        with therect do
            setrectrgn(thergn, left, top, right, bottom);
        lupdate(thergn, list);
        framerect(therect);
    end;

    procedure callupdate;
        function digit2 (num: integer): str255;
            var
                temp: str255;
        begin
            numtostring(num, temp);
            if num < 10 then
                digit2 := concat('0', temp)
            else
                digit2 := temp;
        end;
        var
            thecell: cell;
            temp, scratch: str255;
    begin
        numtostring(current.hour, scratch);
        if editing > ehour then
            scratch := concat(scratch, ':', digit2(current.min));
        if editing > emin then
            scratch := concat(scratch, ':', digit2(current.sec));
        thecell.h := 0;
        thecell.v := pred(maxhist);
        case state of
            first:
                scratch := concat(' ', scratch);
            add:
                scratch := concat('+', scratch);
            sub:
                scratch := concat('-', scratch);
            eq:
                scratch := concat('=', scratch);
        end;
        if current.negative then
            scratch := concat(scratch, '  (-)');
        lsetcell(pointer(succ(ord(@scratch))), length(scratch), thecell, list);
        lscroll(0, maxhist, list);
    end;

    procedure currentdoneprep;
    begin
        with current do begin
                if editing < esec then begin
                        sec := min;
                        min := hour;
                        hour := 0;
                    end;
                if editing < emin then begin
                        sec := min;
                        min := hour;
                        hour := 0;
                    end;
                editing := esec;
                total := sec + min * 60 + longint(hour) * 3600;
            end;
    end;

    procedure currentdone;
        var
            temp: integer;
    begin
        with current do begin
                negative := total < 0;
                total := abs(total);
                sec := total mod 60;
                min := (total div 60) mod 60;
                hour := total div 3600;
            end;
        callupdate;
        if state = sub then
            memory := memory - current.total
        else
            memory := memory + current.total;
        temp := laddrow(1, maxhist, list);
        ldelrow(1, 0, list);
        current.hour := 0;
        current.min := 0;
        current.sec := 0;
        current.negative := false;
        editing := ehour;
    end;

    procedure copy;
        var
            thecell: cell;
            len: integer;
            temp: array[0..127] of integer;
    begin
        thecell.h := 0;
        thecell.v := pred(maxhist);
        if zeroscrap = 0 then begin
                len := 256;
                lgetcell(@temp, len, thecell, list);
                if putscrap(pred(len), 'TEXT', pointer(succ(ord(@temp)))) <> 0 then
                    sysbeep(1);
            end
        else
            sysbeep(1);
    end;

    procedure number (num: integer);
    begin
        with current do
            case editing of
                ehour:
                    hour := (longint(hour) * 10 + num) mod 10000;
                emin:
                    min := (min * 10 + num) mod 100;
                esec:
                    sec := (sec * 10 + num) mod 100;
            end;
        callupdate;
    end;

    procedure colon;
    begin
        if editing < esec then
            editing := succ(editing)
        else
            sysbeep(1);
        callupdate;
    end;

    procedure paste;
        type
            data = packed array[0..32000] of char;
            dataptr = ^data;
            datahandle = ^dataptr;
        var
            err: boolean;
            temp: datahandle;
            i, len: integer;
            offset: longint;
    begin
        err := false;
        temp := datahandle(newhandle(0));
        len := getscrap(handle(temp), 'TEXT', offset);
        writeln(len);
        if (len < 0) or (len > 20) then
            sysbeep(1)
        else begin
                current.hour := 0;
                current.min := 0;
                current.sec := 0;
                current.negative := false;
                editing := ehour;
                for i := 0 to pred(len) do begin
                        writeln(i, ',', temp^^[i]);
                        case temp^^[i] of
                            '0'..'9':
                                number(ord(temp^^[i]) - 48);
                            ':', '.':
                                colon;
                            '-':
                                current.negative := true;
                            otherwise
                                err := true;
                        end;
                    end;
                if temp <> nil then
                    disposhandle(handle(temp));
                if err then
                    sysbeep(1);
                callupdate;
            end;
    end;

    procedure plus;
    begin
        currentdoneprep;
        currentdone;
        state := add;
        callupdate;
    end;

    procedure minus;
    begin
        currentdoneprep;
        currentdone;
        state := sub;
        callupdate;
    end;

    procedure equals;
    begin
        currentdoneprep;
        currentdone;
        state := eq;
        current.total := memory;
        editing := esec;
        currentdone;
        state := first;
        callupdate;
        memory := 0;
    end;

    procedure liststuff (event: eventrecord);
        var
            temp: boolean;
            newdialog: dialogptr;
            thergn: rgnhandle;
            therect: rect;
    begin
        setport(thedialog);
        globaltolocal(event.where);
        if event.where.h > listrect.right then
            temp := lclick(event.where, event.modifiers, list)
        else begin
                newdialog := getnewdialog(129, nil, pointer(-1));
                thergn := newrgn;
                with newdialog^.portrect do
                    setrect(therect, left - 1, top - 1, right + 16, bottom + 1);
                with therect do
                    setrectrgn(thergn, left, top, right, bottom);
                updtdialog(newdialog, thergn);
                while stilldown do
                    ;
                repeat
                until getnextevent(mdownmask, event);
                disposdialog(newdialog);
            end;
    end;

{Main Program}
    var
        a: char;
        i, j, k, item: integer;
        r: rect;
        where, cell, csize: point;
        databounds: rect;
        event: eventrecord;
        temp: handle;
        done, trapit: boolean;
begin
    done := false;
    state := first;
    editing := ehour;
    memory := 0;
    current.hour := 0;
    current.min := 0;
    current.sec := 0;
    current.negative := false;
    thedialog := getnewdialog(128, @dstorage, pointer(-1));
    getditem(thedialog, 18, item, temp, listrect);
    setditem(thedialog, 18, item, @drawlist, listrect);
    setrect(databounds, 0, 0, 1, maxhist);
    csize.h := listrect.right - listrect.left - 15;
    csize.v := 16;
    listrect.right := listrect.right - 17;
    list := lnew(listrect, databounds, csize, 0, thedialog, false, false, false, true);
    callupdate;
    lscroll(0, maxhist, list);
    selectwindow(thedialog);
    list^^.listflags := 0;
    list^^.selflags := lonlyone;
    repeat
        initcursor;
        repeat
            systemtask;
        until getnextevent(everyevent, event);
        item := bitand(event.message, charcodemask);
        trapit := false;
        if ((event.what = keydown) or (event.what = autokey)) and (bitand(event.modifiers, cmdkey + optionkey) = 0) then
            case item of
                48..57:
                    begin
                        item := item - ord('0') + 4;
                        trapit := true;
                    end;
                46, 58:
                    begin
                        item := 14;
                        trapit := true;
                    end;
                43:
                    begin
                        item := 15;
                        trapit := true;
                    end;
                45:
                    begin
                        item := 16;
                        trapit := true;
                    end;
                3, 13, 61:
                    begin
                        item := 17;
                        trapit := true;
                    end;
                otherwise
                    ;
            end;
        if ((event.what = keydown) or (event.what = autokey)) and (bitand(event.modifiers, cmdkey + optionkey) = cmdkey) then
            case item of
                99:
                    copy;
                118:
                    paste;
                113:
                    done := true;
                otherwise
                    ;
            end;
        if not trapit then
            if isdialogevent(event) then
                if dialogselect(event, thedialog, item) then
                    trapit := true;
        if trapit then
            case item of        {QCP0123456789:+-=L}
                1:
                    done := true;
                2:
                    copy;
                3:
                    paste;
                4..13:
                    number(item - 4);
                14:
                    colon;
                15:
                    plus;
                16:
                    minus;
                17:
                    equals;
                18:
                    liststuff(event);
            end;
    until done;
    disposdialog(thedialog);
end.